Cream of the Crop 26/Cream of the Crop 26.iso/program/p063b9s.zip/UNIT/ISRES.PAS

Pascal/Delphi Source File | 1996-04-20 | 6KB | 192 lines

{$S-,R-,V-,I-,B-,F-}

{*********************************************************}
{*                    ISRES.PAS 1.00                     *}
{*        Copyright (c) TurboPower Software 1990.        *}
{*                  All rights reserved.                 *}
{*********************************************************}

unit IsRes;
  {-Routines that allow a program to determine if another copy of itself is
    already resident in memory}

interface

USES Use32;

type
  ProgramName = string[8];

procedure Install(Name : ProgramName; UserHook : Pointer);
  {-Install this program}

procedure Uninstall;
  {-Uninstall this program}

function IsLoaded(Name : String; var UserHook : Pointer) : Boolean;
  {-Returns True if Name is loaded}

procedure Init16;
  {-Install interrupt handler. Called automatically when program begins}

procedure Restore16;
  {-Restore INT $16 vector. Called automatically when program ends}

  {==========================================================================}

implementation

type
  IfcPtr = ^IfcRecord;
  IfcRecord =               {*** do not change!! ***}
    record
      NamePtr : ^String;
      Version : Word;
      UserPtr : Pointer;
      PrevIfc : IfcPtr;
      NextIfc : IfcPtr;
      PrgName : ProgramName;
    end;
const
  IfcSignature1   = $0F0F0;    {*** do not change!! ***}
  IfcSignature2   = $0E0E0;    {*** do not change!! ***}
var
  SaveExitProc    : Pointer;
  ThisIfcPtr      : IfcPtr;
  IfcInstalledPtr : ^Boolean;

  {$L ISRES.OBJ}

  procedure Init16; external;
  procedure Restore16; external;
  procedure ThisIfc; external;

  function GetLastModulePtr : IfcPtr;
    {-Return a pointer to the last module loaded before us}
  var
    FoundIfc : Boolean;
    P : IfcPtr;
    IACAptr : Pointer absolute $40:$F0;
    SaveIACA : Pointer;
  begin
    {assume failure}
    P := nil;
    SaveIACA := IACAptr;
    IACAptr := nil;

    inline(
      $B8/>IfcSignature1/    {mov ax,>IfcSignature1  ;standard interface function code}
      $31/$FF/               {xor di,di              ;es:di = nil}
      $8E/$C7/               {mov es,di}
      $CD/$16/               {int $16                ;call INT 16}
      $F7/$D0/               {not ax                 ;flip bits}
      $3D/>IfcSignature1/    {cmp ax,>IfcSignature1  ;AX = IfcSignature1 only if INT 16 flipped bits}
      $75/$1E/               {jne Done               ;Ifc handler not found?}
      $8C/$C0/               {mov ax,es              ;use second method if es:di = nil}
      $09/$F8/               {or ax,di}
      $74/$08/               {jz NotFound}
      $89/$7E/<P/            {mov [bp+<P],di         ;offset of list pointer in P}
      $8C/$46/<P+2/          {mov [bp+<P+2],es       ;segment of list pointer in P}
      $EB/$0C/               {jmp short Found}
                             {NotFound:              ;try second method - SuperKey can defeat the first}
      $B8/>IfcSignature2/    {mov ax,>IfcSignature2  ;secondary function code}
      $CD/$16/               {int $16                ;call INT 16}
      $F7/$D0/               {not ax                 ;AX = not AX}
      $3D/>IfcSignature2/    {cmp ax,>IfcSignature2  ;AX = IfcSignature2?}
      $75/$04/               {jne Done               ;Ifc handler not found?}
                             {Found:}
      $C6/$46/<FoundIfc/$01);{mov [bp+<FoundIfc],1   ;set Found flag}
                             {Done:}

      if not FoundIfc then
        GetLastModulePtr := nil
      else if P <> nil then
        GetLastModulePtr := P
      else
        GetLastModulePtr := IACAptr;

      {restore intra-applications comm. area}
      IACAptr := SaveIACA;
  end;

  procedure Install(Name : ProgramName; UserHook : Pointer);
    {-Install this program}
  var
    P : IfcPtr;
  begin
    if (Name <> '') and not IfcInstalledPtr^ then
      with ThisIfcPtr^ do begin
        {see if anyone else is home}
        P := GetLastModulePtr;
        if P <> nil then begin
          P^.NextIfc := ThisIfcPtr;
          PrevIfc := P;
        end
        else
          PrevIfc := nil;

        {initialize the other fields in the record}
        PrgName := Name;
        NextIfc := nil;
        UserPtr := UserHook;

        IfcInstalledPtr^ := True;
      end;
  end;

  procedure Uninstall;
    {-Uninstall this program}
  begin
    if IfcInstalledPtr^ then
      with ThisIfcPtr^ do begin
        {fix the linked list of modules}
        if PrevIfc <> nil then
          PrevIfc^.NextIfc := NextIfc;
        if NextIfc <> nil then
          NextIfc^.PrevIfc := PrevIfc;
        IfcInstalledPtr^ := False;
      end;
  end;

  function IsLoaded(Name : String; var UserHook : Pointer) : Boolean;
    {-Returns True if Name is loaded}
  var
    P : IfcPtr;
  begin
    {search backward through the list}
    P := GetLastModulePtr;
    while (P <> nil) do begin
      if P^.NamePtr^ = Name then begin
        UserHook := P^.UserPtr;
        IsLoaded := True;
        Exit;
      end;
      P := P^.PrevIfc;
    end;

    {search failed}
    IsLoaded := False;
  end;

  procedure OurExitProc; far;
    {-Error/exit handler}
  begin
    {restore previous exit handler}
    ExitProc := SaveExitProc;

    {remove the program from the list}
    Uninstall;

    {restore INT $16}
    Restore16;
  end;

begin
  {take over INT $16 and initialize pointers}
  Init16;

  {set up exit handler}
  SaveExitProc := ExitProc;
  ExitProc := @OurExitProc;
end.